home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue33 / packlist / main.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-03-03  |  9.4 KB  |  327 lines
  1. unit Main;
  2. { $M 40960, 8192}
  3.  
  4. interface
  5.  
  6. uses
  7.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  8.   Forms, Dialogs, FileCtrl, StdCtrls, Buttons, Outline, ExtCtrls, Tabs,
  9.   Grids;
  10.  
  11. type
  12.   TCVCSMain = class(TForm)
  13.     Panel1: TPanel;
  14.     Panel2: TPanel;
  15.     TabSet1: TTabSet;
  16.     Notebook1: TNotebook;
  17.     Outline1: TOutline;
  18.     Label1: TLabel;
  19.     DriveComboBox1: TDriveComboBox;
  20.     DirectoryListBox1: TDirectoryListBox;
  21.     FileListBox1: TFileListBox;
  22.     Label2: TLabel;
  23.     SpeedButton2: TSpeedButton;
  24.     SpeedButton1: TSpeedButton;
  25.     SaveDialog1: TSaveDialog;
  26.     CheckBox1: TCheckBox;
  27.     Label3: TLabel;
  28.     ListBox1: TListBox;
  29.     Label4: TLabel;
  30.     ComboBox1: TComboBox;
  31.     procedure FileListBox1DblClick(Sender: TObject);
  32.     procedure SpeedButton2Click(Sender: TObject);
  33.     procedure FormCreate(Sender: TObject);
  34.     procedure FormDestroy(Sender: TObject);
  35.     procedure SpeedButton1Click(Sender: TObject);
  36.   private
  37.     { Private declarations }
  38.     ExcludeList: TStringList;
  39.     procedure BuildList(FName: string; var Level: integer);
  40.     function Parse(var ParseStr: string): string;
  41.     function GetUsesClause(FName: string): string;
  42.     procedure FindUnit(var FName: string);
  43.     procedure OutputHtml(FName: string);
  44.   public
  45.     { Public declarations }
  46.   end;
  47.  
  48. var
  49.   CVCSMain: TCVCSMain;
  50.  
  51. implementation
  52.  
  53. {$R *.DFM}
  54.  
  55. { GetUsesClause - routine to extract the uses clause from a unit }
  56. function TCVCSMain.GetUsesClause(FName: string): string;
  57. var
  58.   AStream: TFileStream;
  59.   Parser: TParser;
  60.   BeginCopy,
  61.   FoundUses,
  62.   IsComment: boolean;
  63.   S: string;
  64. begin
  65.   { initiallize variables }
  66.   Result := '';
  67.   BeginCopy := false;
  68.   FoundUses := false;
  69.   IsComment := false;
  70.   try
  71.     { open FileStream(FName) }
  72.     AStream := TFileStream.Create(FName, fmOpenRead);
  73.     { create unit parser }
  74.     Parser := TParser.Create(AStream);
  75.     try
  76.       with Parser do
  77.         while Token <> toEOF do
  78.         begin
  79.           S := TokenString;
  80.           case Token of
  81.             toSymbol: begin
  82.                 if (TokenString = 'implementation') and not IsComment then
  83.                   FoundUses := true;
  84.                 if (TokenString = 'uses') and not IsComment then
  85.                 begin
  86.                   BeginCopy := true;
  87.                   S := '';
  88.                 end;
  89.               end;
  90.             ';': begin
  91.                 if FoundUses then Exit;
  92.                 if BeginCopy then
  93.                 begin
  94.                   AppendStr(Result, ',');
  95.                   BeginCopy := false;
  96.                 end;
  97.               end;
  98.             '{': begin
  99.                 S := '';
  100.                 IsComment := true;
  101.               end;
  102.             '}': begin
  103.                 S := '';
  104.                 IsComment := false;
  105.               end;
  106.           end;
  107.           if BeginCopy and not IsComment then AppendStr(Result, S);
  108.           NextToken;
  109.         end;
  110.     finally
  111.       Parser.Free;
  112.       AStream.Free;
  113.     end;
  114.   except
  115.     { on file open error return empty string }
  116.     on EFOpenError do Result := '';
  117.   end;
  118. end;
  119.  
  120. { Parse - routine to parse the uses clause }
  121. function TCVCSMain.Parse(var ParseStr: string): string;
  122. var
  123.   Len: integer;
  124. begin
  125.   Result := '';
  126.   if Length(ParseStr) > 0 then { if there is something to parse... }
  127.   begin
  128.     repeat
  129.       if Pos(',', ParseStr) <> 0 then  { if there is a comma... }
  130.       begin
  131.         { copy up to it }
  132.         Len := Pos(',', ParseStr);
  133.         Result := System.Copy(ParseStr, 1, Len-1);
  134.       end else
  135.       begin
  136.         { else copy all remaining string }
  137.         Len := Length(ParseStr);
  138.         Result := System.Copy(ParseStr, 1, Len);
  139.       end;
  140.       { delete what we copied }
  141.       System.Delete(ParseStr, 1, Len);
  142.       { if we have a valid unit name... }
  143.       if IsValidIdent(Result) then Result := Result+'.pas' { add .pas extension }
  144.       else Result := ''; { else return empty string }
  145.     { ...until there is a unit NOT in the exclude list }
  146.     until (ExcludeList.IndexOf(Result) < 0);
  147.   end;
  148. end;
  149.  
  150. procedure TCVCSMain.FindUnit(var FName: string);
  151. var
  152.   FN, TempStr: string;
  153. begin
  154.   FN := FName; { set FN equal to FName }
  155.   { perform the search }
  156.   TempStr := FileSearch(FN, ComboBox1.Text);
  157.   { if successful change FName }
  158.   if TempStr <> '' then FName := ExpandFileName(TempStr);
  159. end;
  160.  
  161. { BuildList - recursive routine to ''walk'' the units tree }
  162. procedure TCVCSMain.BuildList(FName: string; var Level: integer);
  163. var
  164.   NextFile, Remaining: string;
  165.   Idx: integer;
  166. begin
  167.   { find the file on the path }
  168.   FindUnit(FName);
  169.   { add node for file }
  170.   Idx := Outline1.Add(Outline1.SelectedItem, FName);
  171.   Outline1.Items[Idx].Level := Level;
  172.   { add file to exclude list to avoid infinite
  173.     recursion from circular unit references }
  174.   ExcludeList.Add(ExtractFileName(FName));
  175.   { get the uses clause from FName }
  176.   Remaining := GetUsesClause(FName);
  177.   { parse the units clause }
  178.   NextFile := Parse(Remaining);
  179.   while NextFile <> '' do { if NextFile is not empty... }
  180.   begin
  181.     { Inc tree level }
  182.     Inc(Level);
  183.     { recurse with first dependant file }
  184.     BuildList(NextFile, Level);
  185.     { find next dependant file }
  186.     NextFile := Parse(Remaining);
  187.     { Dec tree level }
  188.     Dec(Level);
  189.   end;
  190. end;
  191.  
  192. procedure TCVCSMain.FileListBox1DblClick(Sender: TObject);
  193. var
  194.   L: integer;
  195. begin
  196.   L := 1;
  197.   Screen.Cursor := crHourglass;
  198.   try
  199.     { clear the exclude list }
  200.     ExcludeList.Clear;
  201.     { if user want''s to use the exclude list... }
  202.     if CheckBox1.Checked then ExcludeList.Assign(ListBox1.Items);
  203.     { call BuildList to fill the Outline }
  204.     BuildList(FileListBox1.Items[FileListBox1.ItemIndex], L);
  205.     { Expand the Outline }
  206.     Outline1.FullExpand;
  207.   finally
  208.     Screen.Cursor := crDefault;
  209.   end;
  210. end;
  211.  
  212. procedure TCVCSMain.SpeedButton2Click(Sender: TObject);
  213. begin
  214.   { clear the Outline }
  215.   Outline1.Clear;
  216. end;
  217.  
  218. procedure TCVCSMain.FormCreate(Sender: TObject);
  219. begin
  220.   { create the exclude list }
  221.   ExcludeList := TStringList.Create;
  222.   ExcludeList.Sorted := true;
  223.   ExcludeList.Duplicates := dupIgnore;
  224.   { add possible exclude items to the list box }
  225.   ListBox1.Items.Add ('Windows.pas');
  226.   ListBox1.Items.Add ('WinTypes.pas');
  227.   ListBox1.Items.Add ('WinProcs.pas');
  228.   ListBox1.Items.Add ('SysUtils.pas');
  229.   ListBox1.Items.Add ('System.pas');
  230.   ListBox1.Items.Add ('Classes.pas');
  231.   ListBox1.Items.Add ('ClipBrd.pas');
  232.   ListBox1.Items.Add ('Messages.pas');
  233.   ListBox1.Items.Add ('Graphics.pas');
  234.   ListBox1.Items.Add ('Controls.pas');
  235.   ListBox1.Items.Add ('Forms.pas');
  236.   ListBox1.Items.Add ('Dialogs.pas');
  237.   ListBox1.Items.Add ('Menus.pas');
  238.   ListBox1.Items.Add ('Mask.pas');
  239.   ListBox1.Items.Add ('Outline.pas');
  240.   ListBox1.Items.Add ('StdCtrls.pas');
  241.   ListBox1.Items.Add ('ExtCtrls.pas');
  242.   ListBox1.Items.Add ('FileCtrl.pas');
  243.   ListBox1.Items.Add ('Buttons.pas');
  244.   ListBox1.Items.Add ('Tabs.pas');
  245.   ListBox1.Items.Add ('TabNotBk.pas');
  246.   ListBox1.Items.Add ('Grids.pas');
  247.   ListBox1.Items.Add ('Printers.pas');
  248.   ListBox1.Items.Add ('DDEMan.pas');
  249.   ListBox1.Items.Add ('MPlayer.pas');
  250.   ListBox1.Items.Add ('TOCtrl.pas');
  251.   ListBox1.Items.Add ('IniFiles.pas');
  252.   ListBox1.Items.Add ('DsgnIntf.pas');
  253.   ListBox1.Items.Add ('ToolIntf.pas');
  254.   ListBox1.Items.Add ('DB.pas');
  255.   ListBox1.Items.Add ('DBTables.pas');
  256.   ListBox1.Items.Add ('DBLookup.pas');
  257.   ListBox1.Items.Add ('DBGrids.pas');
  258.   ListBox1.Items.Add ('DBiTypes.pas');
  259.   ListBox1.Items.Add ('DBiProcs.pas');
  260.   ListBox1.Items.Add ('DBCtrls.pas');
  261.   ListBox1.Items.Add ('DBiErrs.pas');
  262.   { assign ListBox1.Items to exclude list
  263.     since this is the default }
  264.   ExcludeList.Assign(ListBox1.Items);
  265. end;
  266.  
  267. procedure TCVCSMain.FormDestroy(Sender: TObject);
  268. begin
  269.   { free the exclude list }
  270.   ExcludeList.Free;
  271. end;
  272.  
  273. { OutputHtml - routine to write ouptu in Html format }
  274. procedure TCVCSMain.OutputHtml(FName: string);
  275. var
  276.   F: TextFile;
  277.   i, j, CurLev: integer;
  278. begin
  279.   CurLev := 0;
  280.   AssignFile(F, FName);
  281.   Rewrite(F);
  282.   { write Html header }
  283.   writeln(F, '<HTML>');
  284.   writeln(F, '<HEAD><TITLE>Packing List</TITLE>');
  285.   writeln(F, '</HEAD>');
  286.   writeln(F, '<BODY BGCOLOR="#FFFFFF" TEXT="#000000" LINK="#0000FF" VLINK="#00009B" ALINK="#DA0000">');
  287.   writeln(F, '<H1>Packing List</H1>');
  288.   writeln(F, '<HR>');
  289.   try
  290.     { iterate through the outline }
  291.     for i := 0 to Outline1.Lines.Count-1 do
  292.     begin
  293.       { if level goes up... }
  294.       if Outline1.Items[i+1].Level > CurLev then
  295.       begin
  296.         write(F, '<UL>'); { increase indent }
  297.         Inc(CurLev);      { increase CurLev }
  298.       end;
  299.       { if level goes down... }
  300.       if Outline1.Items[i+1].Level < CurLev then
  301.         { for CurLev down to the new level }
  302.         for j := CurLev downto Outline1.Items[i+1].Level+1 do
  303.         begin
  304.           write(F, '</UL>'); { close list level }
  305.           Dec(CurLev);  { decrease CurLev }
  306.         end;
  307.       write(F, #13#10);
  308.       write(F, '<LI>'+Outline1.Items[i+1].Text); { write out the actual text }
  309.     end;
  310.     for j := CurLev downto 0 do write(F, '</UL>'); { close all list levels }
  311.     { Html footer }
  312.     write(F, '<HR>'#13#10'Generated by CVCS from');
  313.     writeln(F, ' HomeGrown Software, by Paul Warren.');
  314.     writeln(F, '</BODY></HTML>');
  315.   finally
  316.     CloseFile(F);
  317.   end;
  318. end;
  319.  
  320. procedure TCVCSMain.SpeedButton1Click(Sender: TObject);
  321. begin
  322.   if SaveDialog1.Execute then
  323.     OutputHtml(SaveDialog1.FileName);
  324. end;
  325.  
  326. end.
  327.